COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(DECLARE (fasload struct fas dsk (mac lsp))
C00011 00003	(declare (gc))
C00041 ENDMK
C⊗;
(DECLARE (fasload struct fas dsk (mac lsp))
	 (mapex t)
	 (*lexpr λ-UNSUBST QV-QUASI-UNSUBST NORMALIZE-CMPD-CONCEPT
		 ANALYZE-CMPD-CONCEPT)
	 (load '|nsublis.lsp|)

	 (special QV-SUBSTLIST UQ-LIST CURRENTPOS SUBSTLISTPTR GENVARINDEX
		  GENVAR-RANGES BREAK-POINTS BREAK-BEFORE-POINTS *CONCEPTS*
		  ALPHABET REVERSE-ALPHABET ALPHA-NCONSES *NOPOINT
		  ↑-MATRIX-ANALYSIS-LIST JUNCT-ANALYSIS-LIST ANALYSIS-LIST
		  TERMCOPIES TCOPYPAIR *-ASCII AL-VARS RO-INDEX CURRENTNODE
		  CURRENT-NODE-PATH VERBOSITY XPDN-HELP-TABLE YHπ-FLAG )

	 (special |cc-op: |  |=>|  | .|  |  |  | ;|  V  C  | |  | - | ) )

(SETQ IBASE 10. BASE 10.)
(SETQ PRINLEVEL 3.)
(SETQ PRINLENGTH 60.)
(LINEL NIL 80)
(SETQ BREAK-POINTS '(|, |  | ∧ |  | ∨ |)	;; possibly also /:
      BREAK-BEFORE-POINTS '(|↑[|) )

(DEFSTRUCT (↑↓-TERM (TYPE TREE))
	   ↑↓-MARKER ↑↓-MATRIX )
(declare (gc))

(DEFSTRUCT (LT-QUANTIFIER (TYPE HUNK) (CONC-NAME LT-))
	   DEPENDENCIES DETERMINER QSORTEXPR SCOPE )

(declare (gc))
(DEFSTRUCT (ROLELINK (TYPE TREE))
	   ROLEMARK ARGUMENT )

(declare (gc))
(DEFSTRUCT (PFC-FORMULA (TYPE TREE))
	   PFC-CONCEPT ROLELINKS )
; PFC-FORMULA => (pred rlnk1 rlnk2 ... rlnkn) or (func rlnk1 rlnk2 ... rlnkn)
;		   or (connective rlnk1 rlnk2 ... rlnkn)

(declare (gc))
(DEFSTRUCT (ROLEXENTRY (TYPE TREE))
	   ROLENAME ROLEPHRASE )

(declare (gc))
(DEFSTRUCT (LT-λ-EXPR (TYPE TREE) (CONC-NAME LT-))
	   (λ-PREFIX (MAKE-LT-λ-PREFIX)) λ-SCOPE )

(declare (gc))
(DEFSTRUCT (LT-λ-PREFIX (TYPE TREE) (BUT-FIRST LT-λ-PREFIX) (CONC-NAME LT-))
	   (λ-MARK 'λ) PATHKEYLISTS )
; PATHKEYLISTS => ((<termsort> <pathkey> {<pathkey>} ... ) ... )

(declare (gc))
(DEFSTRUCT (PATHKEYLIST (TYPE TREE))
	   λ-TERMSORT PATHKEYS )

(declare (gc))
(DEFMACRO *DEFUN ((F-TYPE . F-NAME) ARGLIST . BODY)
  `(PROGN
      (PUTPROP (OR (GET ',F-NAME 'FUNCTIONS) 
		   (PUTPROP ',F-NAME (NCONS "*DEFUN-PLIST") 'FUNCTIONS))
	       ,(COND ((EQ (CAR BODY) '*SYN) `',(CADR BODY))
		      (T `'(LAMBDA ,ARGLIST ,@BODY)) )
	       ',F-TYPE )
      (LET ((OLDMACRO (GET ',F-TYPE 'MACRO))
	    (NEWMACRO '(LAMBDA (FORM)
			`(GET (GET ',(CDR FORM) 'FUNCTIONS) ',',F-TYPE) )) )
	   (COND ((AND OLDMACRO 
		       (NOT (EQUAL OLDMACRO NEWMACRO)) )
		  (TERPRI) (PRINC "Macro ") (PRIN1 ',F-TYPE)
		  (PRINC " already defined differently!")
		  (BREAK *DEFUN) )) )
      (DEFUN ,F-TYPE MACRO (FORM)
	 `(GET (GET ',(CDR FORM) 'FUNCTIONS) ',',F-TYPE) ) ) )

(declare (gc))
(*DEFUN (ISA . COREROLE) (ROLEMARK LT-FORM)
   (MEMQ ROLEMARK (GET (PFC-CONCEPT LT-FORM) 'COREROLES)) )

(declare (gc))
(*DEFUN (THE-FOR:ROLELINK . ROLEPHRASE) (ROLELINK LT-FORM)
   (CDR (ASSQ (ROLEMARK ROLELINK) (GET (PFC-CONCEPT LT-FORM) 'ROLEXICON))) )

(declare (gc))
(*DEFUN (THE-OF:LT-QUANT . QSORT) (LT-QUANT)
   (LET* ((QSORTEXPR (LT-QSORTEXPR LT-QUANT))
	  (ATOMICQSORTEXPR
	    (CASEQ (LT-TYPE QSORTEXPR)
	       (ATOMICPROPO QSORTEXPR)
	       (CONJ-PROPO (ARGUMENT (CAR (ROLELINKS QSORTEXPR)))) ) ) )
	 (COND ((EQ (PFC-CONCEPT ATOMICQSORTEXPR) 'CONCEPT) 
		  (NORMALIZE-TERMSORTEXPR
		   (CONS '↑ (TERMSORT
			     (ARGUMENT
			      (ASSQ 'OBJECT
				    (ROLELINKS ATOMICQSORTEXPR) ) ) )) ) )
	       (T (PFC-CONCEPT ATOMICQSORTEXPR)) )) )

(declare (gc))
(*DEFUN (THE-OF:LT-QUANT . DETERMINER) (LT-QUANT)
    *SYN CAR )
;   *SYN LT-DETERMINER )  This usage causes an "; IMPROPER USE OF MACRO - EVAL"
; error message; what LISP doesn't like here is simply the fact that 
; LT-DETERMINER is a macro.

(declare (gc))
(*DEFUN (THE-OF:LT-λ-PREFIX . PATHKEYLISTS) (λ-PREFIX)
    *SYN CDR )

(declare (gc))
(*DEFUN (THE-OF:LT-QUANT . QSORTEXPR) (LT-QUANTIFIER)
    (CXR 2 LT-QUANTIFIER) )

(declare (gc))
(*DEFUN (THE-OF:LT-QUANT . SCOPE) (LT-QUANTIFIER)
    (CXR 3 LT-QUANTIFIER) )

(declare (gc))
(*DEFUN (THE-OF:LINQUANT . DETERMINER) (LINQUANT)
    (CAR LINQUANT) )

(declare (gc))
(*DEFUN (ISA-OF:LT . λ-EXPR) (LT-FORM)
   (AND (CONSP LT-FORM) (CONSP (CAR LT-FORM)) (MEMQ (CAAR LT-FORM) '(λ LAMBDA))) )

; λ-pair: (<λ-mark> . <termsort-indicator>)
; λ-mark: λ
; termsort-indicator: either <termsort-atom> or (<↑-marker> . <termsort-atom>)
; ↑-marker: either ↑ or ↑n , n being a digit such that 2≤n≤9.
(*DEFUN (ISA . λ-PAIR) (SUBSTFORM)
  (AND (CONSP SUBSTFORM)
       (EQ 'λ (CAR SUBSTFORM))
       (OR (SYMBOLP (CDR SUBSTFORM))
	   (AND (SYMBOLP (CADR SUBSTFORM))
		(EQ '↑ (GETCHAR (CADR SUBSTFORM) 1)) ) ) ) )

(declare (gc))
(*DEFUN (ISA . BREAK-BEFORE-POINT) (PRINTATOM)
   (AND (SYMBOLP PRINTATOM)
	(EQ '↑ (GETCHAR PRINTATOM 1))
	(OR (EQ '/[ (GETCHAR PRINTATOM 2))
	    (EQ '/[ (GETCHAR PRINTATOM 3)) ) ) )
;	(EQ '/[ (CAR (LAST (EXPLODE PRINATOM)))) ) ) ;; too much consing

(declare (gc))
(*DEFUN (ISA . BREAK-POINT) (PRINTATOM)
   (MEMQ PRINTATOM BREAK-POINTS) )

(declare (gc))
(*DEFUN (ISA . ROLELINK) (LT-FORM)
   (AND (CONSP LT-FORM) (EQ (GET (CAR LT-FORM) 'CATEGORY) 'ROLEMARK)) )

(declare (gc))
(*DEFUN (ISA-OF:LIN . QUANTIFIER) (LINFORM)
   (EQ (GET (CAR LINFORM) 'CATEGORY) 'DETERMINER) )

(declare (gc))
(*DEFUN (ISA-OF:LT . QUANTIFIER) (LT-FORM)
   (EQ (GET (#.(THE-OF:LT-QUANT . DETERMINER) LT-FORM) 'CATEGORY) 'DETERMINER) )

(declare (gc))
(DEFMACRO E:DO (STRING)
  `(EM:ECOMMANDS (EXPLODEC ,STRING)) )

(declare (gc))
(DEFMACRO E:VAR (VARNAME)
  `(CDAR (EM:READONLY-VARS '(,VARNAME))) )

(declare (gc))
(DEFUN E:SETLINE (NUMBER)
  (LET ((CHAR-LIST))
       (SETQ *NOPOINT T)
       (SETQ CHAR-LIST (APPEND (MAPCAN #'(LAMBDA (P D) (LIST P D))
				       '(α α α α α)
				       (EXPLODEC NUMBER) )
			       '(α L) ))
       (SETQ *NOPOINT NIL)
       (EM:ECOMMANDS CHAR-LIST) ) )

(declare (gc))
(DEFMACRO CONSP (EXPR)
   `(EQ (TYPEP ,EXPR) 'LIST) )

(declare (gc))
(DEFMACRO LAMBDA-OPR (OBJ)
   `(MEMQ (CAAR ,OBJ) '(LAMBDA λ)) )

(declare (gc))
(DEFMACRO ADDCONC (ADDLIST BASELISTATOM)
   `(SETQ ,BASELISTATOM (NCONC ,ADDLIST ,BASELISTATOM)) )

(declare (gc))
(DEFMACRO ENDCONC (ADDLIST BASELISTATOM)
   `(COND (,BASELISTATOM (NCONC ,BASELISTATOM ,ADDLIST))
	  (T (SETQ ,BASELISTATOM ,ADDLIST)) ) )

(declare (gc))
(DEFMACRO ENDADD (ADDITEM BASELISTATOM)
  `(COND (,BASELISTATOM (NCONC ,BASELISTATOM (NCONS ,ADDITEM)))
	 (T (SETQ ,BASELISTATOM (NCONS ,ADDITEM))) ) )

(declare (gc))
(DEFMACRO RASSQ (KEY A-LIST)
   `(DO ((A-TAIL ,A-LIST (CDR A-TAIL)))
	((NULL A-TAIL))
	(COND ((EQ (CDAR A-TAIL) ,KEY) (RETURN (CAR A-TAIL)))) ) )

(declare (gc))
(DEFMACRO EDITXDO (EXPR &rest BODY)
  `(PROGN (EDIT1 ,EXPR) . 
	 ,(MAPCAR '(LAMBDA (CMD) `(%EVALUATE ',CMD)) BODY) ) )

(declare (gc))
(DEFMACRO EDITDO (&rest BODY)
  `(PROGN . ,(MAPCAR '(LAMBDA (CMD) `(%EVALUATE ',CMD)) BODY) ) )

(declare (gc))
(DEFMACRO COPYLIST (LIST)
  `(APPEND ,LIST NIL) )

(declare (gc))
(DEFMACRO BUTLAST (LIST)
  `(NREVERSE (CDR (REVERSE ,LIST))) )

(declare (gc))
(DEFMACRO REPEAT (NUMBER FORM)
  `(DO ((TALLY ,NUMBER (1- TALLY)))
       ((ZEROP TALLY))
       ,FORM ) )

(declare (gc))
(DEFMACRO SETF* (SETFORM VALUEFORM)
  (LIST 'SETF SETFORM (NSUBLIS `((-*- . ,SETFORM)) VALUEFORM)) )

(declare (gc))
(DEFMACRO SOME (LIST PREDICATE . &opt:STEP-FUNCTION)
  (SETF* PREDICATE (EVAL -*-))
  (COND (&opt:STEP-FUNCTION (SETF* &opt:STEP-FUNCTION (EVAL -*-))))
  `(DO ((LISTAIL ,LIST (,(COND (&opt:STEP-FUNCTION
				 (CAR &opt:STEP-FUNCTION) )
			       (T 'CDR) )
			  LISTAIL )))
       ((NULL LISTAIL) NIL)
       (COND ((,PREDICATE (CAR LISTAIL)) (RETURN LISTAIL))) ) )

(declare (gc))
(DEFMACRO SUBSET (PREDICATE LIST)
  (SETF* PREDICATE (EVAL -*-))
  `(MAPCAN #'(LAMBDA (MEMBER)
	       (COND ((,PREDICATE MEMBER) (NCONS MEMBER))) )
	   ,LIST ) )

(declare (gc))
(DEFUN GOOD-NREVERSE (LIST)
   (COND ((OR (NULL LIST) (NULL (CDR LIST))) LIST)
	 ((OR (NULL (CDDR LIST)) (NULL (CDDDR LIST)))
	     (LET ((REMEM (CAR (LAST LIST))))
		  (RPLACA (LAST LIST) (CAR LIST))
		  (RPLACA LIST REMEM) ) )
	 (T (PROG (TRAILER POINTER LEADER)
		  (SETQ TRAILER (CDR LIST)
			POINTER (CDR TRAILER)
			LEADER (CDR POINTER) )
	      RPT (RPLACD POINTER TRAILER)
		  (COND ((CDR LEADER) (SETQ TRAILER POINTER
					    POINTER LEADER
					    LEADER (CDR LEADER) )
				      (GO RPT) ))
		  (RPLACD (CDR LIST) LEADER)
		  (RPLACD LIST POINTER)
		  (SETQ TRAILER (CAR LEADER))
		  (RPLACA LEADER (CAR LIST))
		  (RETURN (RPLACA LIST TRAILER)) ) ) ) )

(declare (gc))
(DEFUN NSUBLIS (A-LIST S-EXPR &aux SUBSTPAIR)
  (COND ((CONSP S-EXPR)
	   (COND ((CONSP (CAR S-EXPR)) (NSUBLIS A-LIST (CAR S-EXPR)))
		 ((SETQ SUBSTPAIR (ASSQ (CAR S-EXPR) A-LIST))
		    (RPLACA S-EXPR (CDR SUBSTPAIR)) ) )
	   (COND ((CONSP (CDR S-EXPR)) (NSUBLIS A-LIST (CDR S-EXPR)))
		 ((SETQ SUBSTPAIR (ASSQ (CDR S-EXPR) A-LIST))
		    (RPLACD S-EXPR (CDR SUBSTPAIR)) ) )
	   S-EXPR )
	((COND ((SETQ SUBSTPAIR (ASSQ S-EXPR A-LIST)) (CDR SUBSTPAIR))
	       (S-EXPR) )) ) )

(declare (gc))
(DEFMACRO HUNKQUANTP (LT-FORM)
   `(AND (HUNKP ,LT-FORM) (#.(ISA-OF:LT . QUANTIFIER) ,LT-FORM)) )

(declare (gc))
(DEFUN QNSUBLIS (A-LIST S-EXPR)
  (COND ((CONSP S-EXPR)
	  (COND ((CONSP (CAR S-EXPR)) (QNSUBLIS A-LIST (CAR S-EXPR))))
	  (COND ((OR (CONSP (CDR S-EXPR)) (HUNKQUANTP (CDR S-EXPR)))
		  (QNSUBLIS A-LIST (CDR S-EXPR)) )
		((ATOM (CDR S-EXPR))
		  (LET ((SUBSTPAIR (ASSQ (CDR S-EXPR) A-LIST)))
		       (COND (SUBSTPAIR (RPLACD S-EXPR (CDR SUBSTPAIR)))) ) ) )
	  S-EXPR )
	((HUNKQUANTP S-EXPR)
	  (QNSUBLIS A-LIST (LT-QSORTEXPR S-EXPR))
	  (QNSUBLIS A-LIST (LT-SCOPE S-EXPR))
	  S-EXPR )
	((ATOM S-EXPR) S-EXPR)
	(T (BREAK "QNSUBLIS - unrecognized type of S-EXPR.")) ) )

(declare (gc))
(DEFMACRO CONDCARPUSH (PREDEXPR PUSHEXPR STACKEXPR)
  (SETQ PUSHEXPR (NSUBLIS `((-*- . ,PREDEXPR)) PUSHEXPR))
  (SETQ STACKEXPR (NSUBLIS `((-*- . ,PREDEXPR)) STACKEXPR))
  `(COND (,PREDEXPR (CAR (PUSH ,PUSHEXPR ,STACKEXPR)))
	 (T ,PUSHEXPR) ) )

(declare (gc))
(DEFMACRO WRITE BODY
  `(PROGN ,@(MAPCAR #'(LAMBDA (X)
		        (COND ((EQ X 'T) '(TERPRI))
			      ((ATOM X) `(PRINC ,X))
			      ((AND (CONSP X)
				    (MEMQ (CAR X) '(SPACES DISPLAY POSPRINC
						     GO TAB BREAK ERROR )) )
			         X )
			      ((AND (CONSP X)
				    (EQ '* (CAR X)) )
			         `(PRINC ,(CDR X)) )
			      (T `(PRIN1 ,X)) ) )
		    BODY ) ) )

(declare (gc))
(DEFUN SPACES (N)
  (DO ((TALLY N (1- TALLY)))
      ((ZEROP TALLY) T)
      (PRINC '/ ) ) )

(declare (gc))
(DEFMACRO NORMALIZE-CONNECTIVE (CONN)
   `(CASEQ ,CONN
      ((∧ & AND) '∧)
      ((∨ OR) '∨)
      ((¬ ~ NOT) '¬)
      (T (WRITE T "; unrecognized connective: " ,CONN
		(BREAK NORMALIZE-CONNECTIVE) )) ) )

(declare (gc))
(DEFUN LINTYPE (LISPINPUTFORM)
  (COND ((NULL LISPINPUTFORM) (BREAK "LINTYPE - null input form!")) 
	((ATOM LISPINPUTFORM) 'SIMPLETERM) 
	((NOT (CONSP LISPINPUTFORM))
	   (WRITE T "; unexpected input form: " LISPINPUTFORM
		  (BREAK LINTYPE) ) )
	((ATOM (CAR LISPINPUTFORM)) 
	   (COND ((MEMQ (GET (CAR LISPINPUTFORM) 'CATEGORY)
			'(ATTRIBUTE COUNT-SORT CATEGORY SORT) )
		    'ATOMICPROPO )
		 ((EQ (GET (CAR LISPINPUTFORM) 'CATEGORY) 'FUNCTION) 
		    'F-TERM )
		 ((EQ (GET (GETCHAR (CAR LISPINPUTFORM) 1) 'CATEGORY)
		      'SYNTACTIC-MARKER )
		    '↑↓-TERM )
		 ((EQ (GET (NORMALIZE-CONNECTIVE (CAR LISPINPUTFORM)) 'CATEGORY)
		      'CONNECTIVE ) 
		    'CONNPROPO )
		 (T (WRITE T "; unrecognized input form: " LISPINPUTFORM
			   (BREAK LINTYPE) )) ) )
	(T (COND ((EQ (GET (#.(THE-OF:LINQUANT . DETERMINER) (CAR LISPINPUTFORM))
			   'CATEGORY )
		      'DETERMINER ) 'QUANTPROPO)
		 ((EQ (GET (#.(THE-OF:LINQUANT . DETERMINER) (CAR LISPINPUTFORM))
			   'CATEGORY )
		      'LAMBDA-DETERMINER ) 'λ-EXPR)
		 (T (WRITE T "; unrecognized input form: " LISPINPUTFORM
			   (BREAK LINTYPE) )) )) ) )

(declare (gc))
(DEFUN ENCODE-LINFORMULA (FORM &aux QV-SUBSTLIST)
   (LET ((ENCODED-LINFORMULA-S (ENCODE-LINFORMULA-S FORM NIL)))
	(QNSUBLIS QV-SUBSTLIST ENCODED-LINFORMULA-S) ) )

(declare (gc))

(DEFMACRO SETUPQUANTS (QUANTLIST NEWMATRIX)
   `(DO ((QUANTAIL ,QUANTLIST (CDR QUANTAIL)))
	((NULL (CDR QUANTAIL))
	 (PUSH (CONS (LT-SCOPE (CAR QUANTAIL)) (CAR QUANTAIL)) QV-SUBSTLIST)
	 ;; QV-SUBSTLIST: ((<variable> . <quantifier>) ...)
	 (SETF (LT-SCOPE (CAR QUANTAIL)) ,NEWMATRIX) )
	(PUSH (CONS (LT-SCOPE (CAR QUANTAIL)) (CAR QUANTAIL)) QV-SUBSTLIST)
	(SETF (LT-SCOPE (CAR QUANTAIL)) (CADR QUANTAIL)) ) )

(DEFMACRO ORDER-PATHKEYS (PATHKEYLIST)
  `(SORT ,PATHKEYLIST #'ALPHALESSP) )

(declare (gc))

; ENCODE-LINFORMULA-S uses the variable QV-SUBSTLIST freely.
(DEFUN ENCODE-LINFORMULA-S (FORM UQ-LIST)
       ;; UQ-LIST is used to record quantifier dependencies
  (CASEQ (LINTYPE FORM)
     ((ATOMICPROPO F-TERM)
	(TRANSFORM-ROLELINKS FORM)
        (MAPC #'(LAMBDA (RLNK) 
		  (SETF* (ARGUMENT RLNK) (ENCODE-LINFORMULA-S -*- UQ-LIST)) )
	      (ROLELINKS FORM))
	(SETF (ROLELINKS FORM) (ORDER-ROLELINKS FORM))
	FORM )
     (CONNPROPO
        (RPLACA FORM (NORMALIZE-CONNECTIVE (CAR FORM)))
	(TRANSFORM-ROLELINKS FORM)
        (MAPC #'(LAMBDA (RLNK) 
		  (SETF* (ARGUMENT RLNK) (ENCODE-LINFORMULA-S -*- UQ-LIST)) )
	      (ROLELINKS FORM) )
	FORM )
     (QUANTPROPO
        (LET ((QUANTLIST (MAPCAN (FUNCTION ENCODE-QUANT) (BUTLAST FORM)))
	      (NEWMATRIX (ENCODE-LINFORMULA-S (CAR (LAST FORM)) UQ-LIST)) )
	     (SETUPQUANTS QUANTLIST NEWMATRIX)
	     (CAR QUANTLIST) ) )
     (SIMPLETERM
	FORM)
     (↑↓-TERM
 	(RPLACD FORM (CADR FORM))
	(SETF* (↑↓-MATRIX FORM) (ENCODE-LINFORMULA-S -*- UQ-LIST))
	FORM )
     (λ-EXPR
        (RPLACD FORM (ENCODE-LINFORMULA-S (CADR FORM) UQ-LIST))
	(MAP #'(LAMBDA (VARLISTAIL)
		 (LET ((PKEYLIST
			 (MAKE-PATHKEYLIST PATHKEYS
					   (ORDER-PATHKEYS
					     (MAPCAR #'IMPLODE
						     (QV-QUASI-UNSUBST
						           (CAR VARLISTAIL)
							   (LT-λ-SCOPE FORM) ) ) ) ) ))
		      (ADJUST-λ-TERMSORT PKEYLIST FORM)
		      (SETF (CAR VARLISTAIL) PKEYLIST) ) )
	     (CDAR FORM) )
	(SETF* (LT-PATHKEYLISTS FORM) (ORDER-PATHKEYLISTS -*-))
	(λ-UNSUBST FORM NIL) )
     (T (BREAK "ENCODE-LINFORMULA-S - unrecognized formula type.")) ) )